home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 3 / CD ACTUAL 3.iso / linux / incoming / jstools-.6v3 / jstools- / jstools-tk3.6v3.0 / lib / jprompts.tcl < prev    next >
Encoding:
Text File  |  1995-02-09  |  10.3 KB  |  359 lines
  1. # jprompts.tcl - various panels to ask the user for something
  2. # 
  3. # Copyright 1992-1994 by Jay Sekora.  All rights reserved, except 
  4. # that this file may be freely redistributed in whole or in part 
  5. # for non-profit, noncommercial use.
  6.  
  7. ### TO DO
  8. ###   make a real j:prompt_font
  9. ###   eval tcl commands at the global level
  10. ###   checkbox to display output of unix or tcl command
  11.  
  12. ######################################################################
  13. # global variables:
  14. #
  15. global J_PREFS env
  16. if {! [info exists J_PREFS(autoposition)]} {set J_PREFS(autoposition) 0}
  17. if {! [info exists J_PREFS(confirm)]} {set J_PREFS(confirm) 1}
  18. #
  19. ######################################################################
  20.  
  21.  
  22. ######################################################################
  23. # j:prompt ?options? - prompt the user for information
  24. # options are:
  25. #   -text (default "Enter a value:"
  26. #   -default (default "")
  27. #   -cancelvalue (default "")
  28. #   -file (default 0)
  29. #   -title (default "Prompt")
  30. # if $file, then the Tab key will do filename completion
  31. ######################################################################
  32.  
  33. proc j:prompt { args } {
  34.   j:parse_args {
  35.     {text "Enter a value:"}
  36.     {default ""}
  37.     {cancelvalue ""}
  38.     {file 0}
  39.     {title Prompt}
  40.   }
  41.   
  42.   global j_prompt
  43.  
  44.   set old_focus [j:current_focus]    ;# so we can restore original focus
  45.  
  46.   toplevel .pr
  47.   wm title .pr $title
  48.   
  49.   message .pr.msg -width 300 -anchor w -text $text
  50.   entry .pr.field -relief sunken -width 40
  51.   j:buttonbar .pr.b -default ok -buttons [format {
  52.     {ok OK {set j_prompt(result) [.pr.field get]; destroy .pr}}
  53.     {cancel Cancel {set j_prompt(result) {%s}; destroy .pr}}
  54.   } $cancelvalue]
  55.  
  56.   pack .pr.msg -side top -fill both -expand yes -padx 10
  57.   pack .pr.field -side top -padx 10 -pady 10
  58.   pack .pr.b -side bottom -fill x
  59.   pack [j:rule .pr -width 200] -side bottom -fill x
  60.  
  61.   .pr.field delete 0 end
  62.   .pr.field insert end $default
  63.   
  64.   j:dialogue .pr            ;# position in centre of screen
  65.  
  66.   if $file {
  67.     bind .pr.field <Tab> {
  68.       set f [%W get]
  69.       %W delete 0 end
  70.       %W insert end [j:expand_filename $f]
  71.     }
  72.   }
  73.   j:default_button .pr.b.ok .pr.field
  74.   j:cancel_button .pr.b.cancel .pr.field
  75.  
  76.   focus .pr.field
  77.   grab .pr
  78.   tkwait window .pr
  79.   focus $old_focus
  80.   return $j_prompt(result)
  81. }
  82.  
  83. ######################################################################
  84. # j:prompt_font ?options? - prompt for a font (via xfontsel)
  85. # options are:
  86. #   -prompt (default "Font:", but currently ignored)
  87. #   -pattern (default "*")
  88. # usage of xfontsel (`quit' button) not obvious!
  89. ######################################################################
  90.  
  91. proc j:prompt_font { args } {
  92.   j:parse_args {
  93.     {prompt "Font:"}
  94.     {pattern "*"}
  95.   }
  96.   return [exec xfontsel -pattern $pattern -print]
  97. }
  98.  
  99. ######################################################################
  100. # j:prompt_tcl - prompt for a tcl command and execute it
  101. ######################################################################
  102.  
  103. proc j:prompt_tcl {} {
  104.   global j_prompt_tcl
  105.   append j_prompt_tcl(RESULT) {}
  106.  
  107.   set prompt_result [j:prompt \
  108.     -text "Tcl Command:" -default $j_prompt_tcl(RESULT)]
  109.   if {$prompt_result != {}} then {
  110.     set j_prompt_tcl(RESULT) $prompt_result
  111.     set result [uplevel #0 $j_prompt_tcl(RESULT)]
  112.     set length [string length $result]
  113.     if {$length == 0} {
  114.       return
  115.     }
  116.     if {$length < 40 && ! [string match "*\[\t\r\]*" $result]} {
  117.       j:alert -title "Tcl result" -text $result
  118.       return
  119.     } else {
  120.       j:more -title "Result of Tcl command" -text $result
  121.       return
  122.     }
  123.   }
  124. }
  125.  
  126. ######################################################################
  127. # j:prompt_unix - prompt for a unix command and execute it
  128. ######################################################################
  129.  
  130. proc j:prompt_unix {} {
  131.   global j_prompt_unix
  132.   append j_prompt_unix(RESULT) {}
  133.  
  134.   set prompt_result [j:prompt \
  135.     -text "Unix Command:" -default $j_prompt_unix(RESULT)]
  136.   if {$prompt_result != {}} then {
  137.     set j_prompt_unix(RESULT) $prompt_result
  138.     set command $prompt_result
  139.     set result [uplevel #0 exec $command < /dev/null]
  140.     set length [string length $result]
  141.     if {$length == 0} {
  142.       j:alert -text "No output from $command."
  143.       return
  144.     }
  145.     if {$length < 40 && ! [string match "*\[\t\r\]*" $result]} {
  146.       j:alert -title "Command output" -text $result
  147.       return
  148.     } else {
  149.       j:more -title "Output of $command" -text $result
  150.       return
  151.     }
  152.   }
  153. }
  154.  
  155. ######################################################################
  156. # j:prompt_colour_name - prompt for a colour name
  157. ######################################################################
  158. ### PROBLEM: LOCATION OF /usr/lib/X11/rgb.txt IS HARDCODED!
  159. ### Also, should open and process without forking off an awk
  160. ### Also, getting $w into strings is done in an ugly manner
  161.  
  162. proc j:prompt_colour_name { args } {
  163.   j:parse_args {
  164.     {prompt "Choose a colour:"}
  165.     {title "Colour Name Selector"}
  166.   }
  167.   global j_prompt
  168.   global J_PREFS
  169.   if {[lsearch [array names J_PREFS] {scrollbarside}] == -1} {
  170.     set J_PREFS(scrollbarside) right ;# make sure it's defined
  171.   }
  172.   
  173. ###   if {[info exists j_prompt(count)]} then {
  174. ###     set j_prompt(count) [expr {$j_prompt(count) + 1}]
  175. ###   } else {
  176. ###     set j_prompt(count) 0
  177. ###   }
  178. ### 
  179. ###   set w ".prompt$j_prompt(count)"
  180.  
  181.   set w ".prompt_colour_name"
  182.   toplevel $w
  183.   wm title $w $title
  184.   
  185.   set rgbfile /usr/lib/X11/rgb.txt
  186.   if [file isfile $rgbfile] {
  187.     set colourlist [lsort [exec awk { NF == 4 { print $4 } } $rgbfile]]
  188.   } else {
  189.     set colourlist {
  190.       aquamarine bisque black blue brown burlywood coral crimson cyan
  191.       firebrick gold goldenrod green grey grey25 grey33 grey50 grey66
  192.       grey75 khaki lavender magenta maroon navy orange orchid pink plum
  193.       purple red salmon tan tomato turquoise white yellow
  194.     }
  195.   }
  196.   
  197.   set j_prompt(colour) {}
  198.   
  199.   label $w.l -text $prompt
  200.   j:buttonbar $w.b -default ok -orient vertical -buttons [list \
  201.     [list ok OK [format {
  202.         catch {set j_prompt(colour) [%s.list get [%s.list curselection]]}
  203.         destroy %s
  204.       } $w $w $w] \
  205.     ] \
  206.   ]
  207.   frame $w.frame -width 100 -height 100 \
  208.     -background bisque -relief raised -borderwidth 2
  209.   frame $w.list
  210.   scrollbar $w.list.sb -relief flat -command "$w.list.lb yview"
  211.   listbox $w.list.lb -yscroll "$w.list.sb set" -relief flat -setgrid true
  212.   ####### following supports both tk3.6 and 4.0:
  213.   if [catch {$w.list.lb configure -geometry 20x20}] {
  214.     $w.list.lb configure -width 20 -height 20
  215.   }
  216.   
  217.   pack $w.list.sb [j:rule $w.list] \
  218.     -side $J_PREFS(scrollbarside) -fill y
  219.   pack $w.list.lb -in $w.list -side left -expand yes -fill both
  220.   
  221.   pack $w.l [j:rule $w] -side top -fill x
  222.   pack $w.list [j:rule $w] -side left -expand yes -fill both
  223.   pack $w.frame -side top -fill both -expand yes -padx 10 -pady 10
  224.   pack $w.b -side bottom -fill x
  225.   pack [j:rule $w] -side bottom -fill x
  226.   
  227.   # Fill the listbox with a list of several useful colours:
  228.   
  229.   foreach i $colourlist {
  230.     $w.list.lb insert end $i
  231.   }
  232.   
  233.   # Set up bindings for the browser.
  234.   
  235.   bind $w.list.lb <Control-q> "destroy $w"
  236.   bind $w.list.lb <Control-c> "destroy $w"
  237.   focus $w.list.lb
  238.   bind $w.list.lb <Button-1> "
  239.     $w.list.lb select from \[$w.list.lb nearest %y\]
  240.     catch {set j_prompt(colour) \[$w.list.lb get \[$w.list.lb curselection\]\]}
  241.     $w.frame config -background \$j_prompt(colour)
  242.   "
  243.   bind $w.list.lb <Double-Button-1> "
  244.     $w.b.ok invoke
  245.   "
  246.   
  247.   j:default_button $w.b.ok $w
  248.   focus $w
  249.   j:dialogue $w
  250.   tkwait window $w
  251.   if {$j_prompt(colour) == ""} {set j_prompt(colour) bisque}
  252.   return $j_prompt(colour)
  253. }
  254.  
  255. proc j:prompt_color_name \
  256.   [info args j:prompt_colour_name] \
  257.   [info body j:prompt_colour_name]
  258.  
  259. ######################################################################
  260. # j:prompt_colour_rgb - prompt for a colour RGB value
  261. #   An eviscerated version of selcol.tcl by Sam Shen <sls@aero.org>,
  262. #   which also let you choose HSV values
  263. ######################################################################
  264.  
  265. proc j:prompt_colour_rgb { args } {
  266.   j:parse_args {
  267.     {prompt "Choose a colour:"}
  268.     {title "RGB Colour Selector"}
  269.   }
  270.   global j_prompt
  271.   
  272.   set j_prompt(red) 255
  273.   set j_prompt(blue) 196
  274.   set j_prompt(green) 228
  275.   set j_prompt(flag) 0
  276.   
  277.   set w .prompt_rgb
  278.   toplevel $w
  279.   wm title $w $title
  280.   wm minsize $w 100 100
  281.   wm maxsize $w [winfo screenwidth $w] [winfo screenheight $w]
  282.   
  283.   label $w.l -text $prompt
  284.  
  285.   frame $w.patch -width 100 -height 100 -relief raised -borderwidth 2
  286.   entry $w.value -width 12
  287.   bind $w.value <1> {%W select from @0; %W select to end}
  288.   
  289.   frame $w.scales
  290.   set j_prompt(flag) 1
  291.   j:prompt_colour_rgb:make_scale $w $w.scales.red red 255 Red
  292.   j:prompt_colour_rgb:make_scale $w $w.scales.green green 255 Green
  293.   j:prompt_colour_rgb:make_scale $w $w.scales.blue blue 255 Blue
  294.   pack $w.scales.red $w.scales.green $w.scales.blue \
  295.     -side left -fill y -expand yes
  296.   set j_prompt(flag) 0
  297.   
  298.   j:buttonbar $w.b -default ok -orient vertical -buttons {
  299.     {
  300.       ok OK { }
  301.     }
  302.   }
  303.   
  304.   $w.b.ok configure -command "
  305.     set j_prompt(return) \[$w.value get\]
  306.     destroy $w
  307.   "
  308.   
  309.   pack $w.l
  310.   pack [j:rule $w] -fill x
  311.   pack $w.scales -expand yes -side left -fill y
  312.   pack [j:rule $w] -side left -fill y
  313.   pack $w.value -fill both
  314.   pack $w.patch -expand yes -fill both -padx 10 -pady 10
  315.   pack [j:rule $w] -fill x
  316.   pack $w.b -fill x
  317.   
  318.   j:prompt_colour_rgb:update_colour $w red $j_prompt(red)
  319.   
  320.   j:default_button $w.b.ok $w
  321.   focus $w
  322.   j:dialogue $w
  323.   tkwait window $w
  324.   return $j_prompt(return)
  325. }
  326.  
  327. proc j:prompt_colour_rgb:make_scale {w name var to title} {
  328.   global j_prompt
  329.   
  330.   frame $name
  331.   scale $name.scale -to $to \
  332.     -command "j:prompt_colour_rgb:update_colour $w $var"
  333.   $name.scale set [set j_prompt($var)]
  334.   label $name.label -text $title
  335.   pack $name.label -in $name
  336.   pack $name.scale -in $name -expand yes -fill y
  337. }
  338.  
  339. proc j:prompt_colour_rgb:update_colour {w var value} {
  340.   global j_prompt
  341.  
  342.   if {$j_prompt(flag) == 1} {return}
  343.   set j_prompt(flag) 1
  344.   set j_prompt($var) $value
  345.   set colour [format "#%02x%02x%02x" \
  346.     $j_prompt(red) $j_prompt(green) $j_prompt(blue)]
  347.   catch {}
  348.   $w.patch configure -background $colour
  349.   $w.value delete @0 end
  350.   $w.value insert 0 $colour
  351.   set j_prompt(flag) 0
  352. }
  353.  
  354. ######################################################################
  355.  
  356. proc j:prompt_color_rgb \
  357.   [info args j:prompt_colour_rgb] \
  358.   [info body j:prompt_colour_rgb]
  359.